home *** CD-ROM | disk | FTP | other *** search
/ Dr. Windows 3 / dr win3.zip / dr win3 / VISUALBA / DBFM2.ZIP / MYLIB.BAS < prev    next >
BASIC Source File  |  1994-02-06  |  24KB  |  681 lines
  1. Declare SUB IM (xn%, fc$, ifn$, kl%, ky$, rn&, rc%)
  2.  
  3. 'COLOR 14, 1
  4. 'CALL SaveScrn(a$)
  5. 'CLS : FILES
  6. 'CALL SaveScrn(b$)
  7. 'CLS : SHELL "DIR"
  8. 'CALL SaveScrn(c$)
  9. 'CLS
  10. 'PRINT "Press a key...";
  11. 'DO: LOOP WHILE INKEY$ = ""
  12. 'CALL RestoreScrn(c$)
  13. 'CALL PopWindow(10, 10, 20, 70, 78)
  14. 'LOCATE 25, 1
  15. 'PRINT "Press a key...";
  16. 'DO: LOOP WHILE INKEY$ = ""
  17. 'CALL RestoreScrn(b$)
  18. 'LOCATE 25, 1
  19. 'PRINT "Press a key...";
  20. 'DO: LOOP WHILE INKEY$ = ""
  21. 'CALL RestoreScrn(a$)
  22. 'LOCATE 25, 1
  23. 'PRINT "Press a key...";
  24. 'CLS
  25. 'END
  26.  
  27. SUB AddKeyRec (krs%, ky$, Rec$, rn&, status%) public
  28.   CALL Info(krs%, xn%, kl%, Rfn%, Rfl%)
  29.   if Rfl%>0 then rn& = (LOF(Rfn%) \ Rfl%) + 1
  30.   fc$ = "A": CALL im(xn%, fc$, ifn$, kl%, ky$, rn&, rc%)
  31.   status% = rc%    ' rc% = 109 is duplicate key
  32.   IF rc% <> 0 THEN
  33.     CALL IndexError(rc%)
  34.   ELSE
  35.     IF LEN(Rec$) < Rfl% THEN Rec$ = Rec$ + SPACE$(Rfl% - LEN(Rec$))
  36.     if len(Rec$)>0 and rn&>0 then PUT #Rfn%, rn&, Rec$
  37.   END IF
  38. END SUB
  39.  
  40. SUB Cdate (dt$) public
  41.   ' Format Date$ converted to YYMMDD  dt$ passed as ""
  42.   ' Format YYMMDDD converted to MM-DD-YY
  43.   IF LEN(dt$) = 6 THEN
  44.     dt$ = MID$(dt$, 3, 2) + "-" + MID$(dt$, 5, 2) + "-" + MID$(dt$, 1, 2)
  45.   END IF
  46.   IF LEN(dt$) = 0 THEN
  47.     dt$ = MID$(DATE$, 9, 2) + MID$(DATE$, 1, 2) + MID$(DATE$, 4, 2)
  48.   END IF
  49. END SUB
  50.  
  51. FUNCTION ColorAttribute% (row%, col%)  public
  52.   DEF SEG = GetVideoSegment
  53.   '*** Determine the background color of the cel at row%, col% ****
  54.   step1% = (PEEK(((row% - 1) * 160) + ((col% - 1) * 2) + 1) AND &HFF)
  55.   ColorAttribute% = step1%
  56.   DEF SEG   '**** Restore BASIC's default data segment ****
  57. END FUNCTION
  58.  
  59. SUB DateEdit (row%, col%, colr%, vk$, dt$, xk%) public
  60.  ' Typ% =1  Edit MM/DD/YYYY  returns YYYYMMDD
  61.  ' Typ% =2  Edit MM/DD/YYYY  returns YYYDDD        YYY= YYYY-1700
  62.  ' Typ% =3  Edit MM/DD/YYYY  returns YYYYDDD
  63.   st$ = dt$: fld% = 10: Typ% = xk%
  64.   FOR xk% = 48 TO 57: vk$ = vk$ + CHR$(xk%): NEXT
  65.   IF colr% = -1 THEN colr% = ColorAttribute%(row%, col%)
  66.   SELECT CASE Typ%
  67.     CASE 1
  68.      st$ = MID$(dt$, 5, 2) + "-" + MID$(dt$, 7, 2) + "-" + MID$(dt$, 1, 4)
  69.     CASE 2
  70.      CALL Julian(st$)          ' get back  MM-DD-YYYY
  71.     CASE 3
  72.      CALL Julian(st$)          ' get back MM-DD-YYYY
  73.   END SELECT
  74.   DO
  75.     CALL FastPrint(row%, col%, st$, colr%)
  76.     IF c% <= 0 THEN c% = 0
  77.     IF c% = 2 THEN c% = 3
  78.     IF c% = 5 THEN c% = 6
  79.     IF c% >= fld% THEN c% = fld% - 1
  80.     LOCATE row%, (col% + c%), 1, 6, 7
  81.     xk% = KeyIn%
  82.     IF xk% > 0 AND xk% < 255 THEN
  83.       IF INSTR(vk$, CHR$(xk%)) AND c% < fld% THEN
  84.          c% = c% + 1: MID$(st$, c%, 1) = CHR$(xk%)
  85.       END IF
  86.     END IF
  87.     SELECT CASE xk%
  88.      CASE 13
  89.       SELECT CASE Typ%
  90.         CASE 1
  91.          dt$ = MID$(st$, 7, 4) + MID$(st$, 1, 2) + MID$(st$, 4, 2)
  92.         CASE 2
  93.          CALL Julian(st$)
  94.          Year% = VAL(MID$(st$, 1, 4)) - 1300
  95.          dt$ = MID$(STR$(Year%), 2) + MID$(st$, 5, 3)
  96.         CASE 3
  97.          CALL Julian(st$): dt$ = st$       ' get back YYYYDDD
  98.       END SELECT
  99.      CASE 8                         ' Backspace Key
  100.        MID$(st$, (c% + 1), 1) = " ": c% = c% - 1
  101.        IF c% = 2 THEN c% = 1
  102.        IF c% = 5 THEN c% = 4
  103.      CASE -46                          ' Alt C to clear field
  104.        st$ = "  -  -    ": c% = 0
  105.      CASE -71
  106.        c% = 0: xk% = 0                  ' Home Key  start of field
  107.      CASE -79
  108.        c% = fld% - 1: xk% = 0           ' End Key  end of field
  109.      CASE -75
  110.        c% = c% - 1: xk% = 0             ' Left Arrow Key
  111.        IF c% = 2 THEN c% = 1
  112.        IF c% = 5 THEN c% = 4
  113.      CASE -77
  114.        c% = c% + 1: xk% = 0             ' Right Arrow Key
  115.        IF c% = 2 THEN c% = 3
  116.        IF c% = 5 THEN c% = 6
  117.     END SELECT
  118.     IF xk% = -77 OR xk% = -75 OR xk% = -83 OR xk% = -82 OR xk% = -46 THEN xk% = 0
  119.     IF xk% < 0 OR xk% = 13 OR xk% = 27 THEN EXIT SUB    ' Exit keys
  120.   LOOP
  121. END SUB
  122.  
  123. FUNCTION DayOfWeek$  public
  124.   IF VAL(dt$) < 1991001 THEN
  125.     ndays& = NumDays("1991003", dt$)
  126.   ELSE
  127.     ndays& = NumDays(dt$, "1991003")
  128.   END IF
  129.   day% = 1 + (ndays& MOD 7)
  130.   SELECT CASE day%
  131.     CASE 1
  132.       DayOfWeek = "Sunday"
  133.     CASE 2
  134.       DayOfWeek = "Monday"
  135.     CASE 3
  136.       DayOfWeek = "Tuesday"
  137.     CASE 4
  138.       DayOfWeek = "Wednesday"
  139.     CASE 5
  140.       DayOfWeek = "Thursday"
  141.     CASE 6
  142.       DayOfWeek = "Friday"
  143.     CASE 7
  144.       DayOfWeek = "Saturday"
  145.     CASE ELSE
  146.       DayOfWeek = "Error"
  147.   END SELECT
  148. END FUNCTION
  149.  
  150. SUB DeleteKeyRec (krs%, ky$, Rec$, status%) public
  151.   ' Deletes Current Key & Data Record or Just Key
  152.   CALL Info(krs%, xn%, kl%, Rfn%, Rfl%)
  153.   fc$ = "R": CALL im(xn%, fc$, ifn$, kl%, ky$, rn&, rc%)
  154.   IF rc% <> 0 THEN CALL IndexError(rc%): EXIT SUB
  155.   fc$ = "D": CALL im(xn%, fc$, ifn$, kl%, ky$, rn&, rc%)
  156.   IF rc% <> 0 THEN
  157.     CALL IndexError(rc%): status% = rc%
  158.   ELSE
  159.     ' Delete Rec$ if Rec$ not a nul
  160.     IF Rec$ <> "" AND Rfn% <> 0 AND rn& > 0 THEN
  161.        Rec$ = SPACE$(Rfl%): PUT #Rfn%, rn&, Rec$
  162.     END IF
  163.   END IF
  164. END SUB
  165.  
  166. SUB EditField (row%, col%, colr%, vk$, st$, xk%) public
  167.   fld% = LEN(st$)
  168.   IF colr% = -1 THEN colr% = ColorAttribute%(row%, col%)
  169.   IF xk% > 10 THEN cap% = 1: xk% = xk% - 10
  170.   SELECT CASE xk%
  171.    CASE 1    ' All keys accepted
  172.      FOR xk% = 32 TO 126: vk$ = vk$ + CHR$(xk%): NEXT
  173.    CASE 2    ' Numeric ONLY
  174.      FOR xk% = 48 TO 57: vk$ = vk$ + CHR$(xk%): NEXT
  175.    CASE 3    ' Numeric DECIMAL
  176.      FOR xk% = 42 TO 57: vk$ = vk$ + CHR$(xk%): NEXT
  177.    CASE 4    ' Alpha ONLY
  178.      FOR xk% = 65 TO 90: vk$ = vk$ + CHR$(xk%): NEXT
  179.      FOR xk% = 97 TO 122: vk$ = vk$ + CHR$(xk%): NEXT
  180.   END SELECT
  181.   DO
  182.     IF cap% = 1 THEN st$ = UCASE$(st$)
  183.     CALL FastPrint(row%, col%, st$, colr%)
  184.     IF c% >= fld% THEN c% = fld% - 1
  185.     IF c% < 0 THEN c% = 0
  186.     LOCATE row%, (col% + c%), 1, 6, 7
  187.     xk% = KeyIn%
  188.     IF xk% > 0 AND xk% < 255 THEN
  189.       IF INSTR(vk$, CHR$(xk%)) AND c% < fld% THEN
  190.         c% = c% + 1:   MID$(st$, c%, 1) = CHR$(xk%)
  191.       END IF
  192.     END IF
  193.     SELECT CASE xk%
  194.      CASE 8                          ' Backspace Key
  195.        MID$(st$, (c% + 1), 1) = " ": c% = c% - 1
  196.      CASE -83                         ' Del Key
  197.        new$ = MID$(st$, 1, c%) + MID$(st$, (c% + 2), fld%) + " "
  198.        st$ = new$: new$ = ""
  199.      CASE -82                           ' Insert Key
  200.        new$ = MID$(st$, 1, c%) + " " + MID$(st$, (c% + 1), (fld% - 1))
  201.        st$ = new$: new$ = ""
  202.      CASE -46                           ' Alt C to clear field
  203.        st$ = SPACE$(fld%): c% = 0
  204.      CASE -71
  205.        c% = 0: xk% = 0                  ' Home Key  start of field
  206.      CASE -79
  207.        c% = fld% - 1: xk% = 0           ' End Key  end of field
  208.      CASE -75
  209.        c% = c% - 1: xk% = 0  ' Left Arrow Key
  210.      CASE -77
  211.        c% = c% + 1: xk% = 0   ' Right Arrow Key
  212.     END SELECT
  213.     IF xk% = -77 OR xk% = -75 OR xk% = -83 OR xk% = -82 OR xk% = -46 THEN xk% = 0
  214.     IF xk% < 0 OR xk% = 13 OR xk% = 27 THEN EXIT SUB    ' Exit keys
  215.   LOOP
  216. END SUB
  217.  
  218. SUB FastPrint (row%, col%, st$, colr%) public
  219.   '**** Get Current screen color if colr% set to -1 *****
  220.   IF colr% = -1 THEN colr% = ColorAttribute%(row%, col%)
  221.   '**** Calculate video memory offset, where display will begin ****
  222.   offset% = 160 * (row% - 1) + 2 * (col% - 1)
  223.   DEF SEG = GetVideoSegment  '** Set default data segment to screen memory  **
  224.   '**** Place the string into video memory, along with the color ****
  225.   stPos% = 1
  226.   FOR x% = 0 TO ((LEN(st$) - 1) * 2) STEP 2
  227.     POKE x% + offset%, ASC(MID$(st$, stPos%, 1))
  228.     POKE x% + offset% + 1, colr%
  229.     stPos% = stPos% + 1
  230.   NEXT x%
  231.   DEF SEG  '**** Restore BASIC's default data segment ****
  232. END SUB
  233.  
  234.  
  235. SUB GetEqual (krs%, ky$, Rec$, rn&, status%) public
  236.   ' to get first record make ky$ < first possible record
  237.   ' to get last record make k$ > last possible record
  238.   CALL Info(krs%, xn%, kl%, Rfn%, Rfl%)
  239.   fc$ = "Q": CALL im(xn%, fc$, ifn$, kl%, ky$, rn&, rc%)
  240.   status% = rc%: Rec$ = SPACE$(Rfl%)
  241.   IF rc% <> 0 THEN
  242.     If rc%> 114 and rc%<117 then
  243.         fc$ = "L" :CALL im(xn%, fc$, ifn$, kl%, ky$, rn&, rc%)
  244.     else
  245.       CALL IndexError(rc%): exit sub
  246.     end if
  247.   end if
  248.     ' Get th